perm filename WRTPAG.F4[PAG,LCS]7 blob
sn#400690 filedate 1978-12-05 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE WRTPAG
C00016 ENDMK
Cā;
SUBROUTINE WRTPAG
DATA SLSP/12.0/
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/JLINE/JLINE,SIZX
1 /SF/KL,RT,KP,SIZE,NAMX,EXT /IPG/IPG
1 ,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
1 /RCLF/KK,CL,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,ITR
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /KNUM/KNUM
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
1/BRJ/JTOT,TURN,NB,DSK,PGLNTH
DIMENSION ENDSTF(450)
C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R7,RQ(5))
1,(R8,RQ(6)),(LCNT,IV(45)),(NDPY,IV(46)),(ENDSTF,KBAR(4))
DATA VERT/0.045/
C VERT IS BASIC VERTICAL UNIT SIZE IN INCHES
IF(MPG.NE.0)GO TO 4
DO 1 K=1,100
1 IF(NBAR(K).EQ.0)GO TO 3
3 MPG=K-1
C SETS NUMB. OF LINES ON FIRST PAGE
4 IF(SPG.EQ.0)SPG=PGLNTH/MPG
RS=SIZE*17.5
HX=0
CC RA=(RSTJ2*SIZE)/RPSZ(1)
RA=RPSZ(JPG)
C SAVE SIZE OF TOP STAFF FOR LATER
DO 141 K=1,JPG
RB=RSTNUM(K)
C ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
RHGT(K)=RHGT(K)+RB*(RS-17.5)
CC RPSZ(K)=RPSZ(K)*RA
141 RPSZ(K)=RPSZ(K)*SIZE
CC141 HX=HX+(RHGT(K)+17.5)*RPSZ(K)*RT
CZZ HX=(17.5*RSTNUM(JPG)+17.5)*VERT
HX=(17.5*RSTNUM(JPG)+17.5+RHGT(JPG)*RA)*VERT
C HX=TOTAL HEIGHT IN INCHES. THIS ASSUMES RSTNUM(JPG) IS HIGHEST STAFF NUM.
C ALSO ASSUMES HIGHEST STAFF NUM. IS REALLY ABOVE ALL OTHERS.
143 IF(HX.LE.SPG)GO TO 140
HX=SPG/HX
C GET THE FACTOR FOR SPACE BETWEEN STAVES
CZZ DO 142 K=1,LPG
CZZ RA=17.5*RSTNUM(K)
CZZ142 RHGT(K)=RA*HX-RA
RA=1/HX
DO 142 K=1,JPG
SP=RHGT(K)
IF(SP)GO TO 1142
C MULT +S * <1, -S * >1 TO REDUCE SIZE
SP=SP*HX
GO TO 142
1142 SP=SP*RA
142 RHGT(K)=SP
CC142 RHGT(K)=(RA+RHGT(K))*HX-RA
140 NPG=1
NMPG='PAGEA'
HORZ=96.
IF(KNUM.GT.0)KNUM=KNUM-1
C FOR PAGE NUMS.
IF(MOD(KNUM,2).NE.0)HORZ=-HORZ
RNUM=0.+KNUM
LB=0
ITR=LL
C TRANSPOSE IS IN LL
RA=0
JEND=-1
METR=1000
CLEF=-99
JSLUR=0
LC=1
KREAD=128
SIG=CLEF
HX=2
KQ=1
KPX=1
CALL FILOUT
C NAMQ AND NPG ARE SET IN FILOUT
SP=2.45
C DEFAULT VERT. SPACE UNITS
ENDSTF(1)=0
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
SP=SP+(HX-2.)*.11
100 CALL FILEIN
320 CALL STAVES
CC IF(IPG)GO TO 3000
IF(NPG.NE.1)GO TO 3000
RT=RSTNUM(JPG)
RS=100.+HORZ
HORZ=-HORZ
RNUM=RNUM+1
C ADDS PAGE NUMBER. SIZE(P6)=1.1 P7=3 SO PARTS PROG. WILL IGNORE IT.
CALL STAFF(5.,10.,RS,28.,RNUM,1.1,3.0,0,0,0,0,0)
3000 IF(ITR.NE.0)CALL TRNSP
JPQ=KL
NA=0
KPT=1
ENDSTF(1)=0
C LOOP STARTS HERE *******
131 NA=NA+1
KWDS(KP)=JPQ
KP=KP+1
R=CODEN(KPN,NA,Q,JK)
RR=Q(JK+6)
RS=Q(JK)
IF(R.NE.5)GO TO 935
R8=-1
IF(RS.GE.6)R8=Q(JK+8)
IF(RR)GO TO 735
IF(RR.LE.Q(JK+3))RR=201.
GO TO 235
C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
935 IF(R.EQ.7)GO TO 835
IF(R.NE.44)GO TO 35
R=R/11.
Q(JK+1)=R
C INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
IF(RR.LT.Q(JK+3))GO TO 30
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
835 R8=0
R7=0
IF(RS.GE.6)R8=Q(JK+8)
235 IF(RR.LT.199.)GO TO 30
C P1,P2,P3,P4,P5,P6,P7,P8 ARE SAVED.
RR=-1
735 IF(RS.GE.5)R7=Q(JK+7)
R4=Q(JK+4)
IF(R.NE.5)GO TO 1735
IF(ABS(R7).LE.1.5)GO TO 2735
C=1.5
C LIMIT CURVE OF SLUR AT END OF LINE TO +-2
IF(R7)C=-C
Q(JK+7)=C
2735 IF(R4.NE.Q(JK+5))GO TO 1735
C IF A SLUR - AND END HGTS ARE SAME MAKE CURVE 1 OR -1.
C=1
IF(R7)C=-C
R7=C
1735 ENDSTF(KPT)=6
ENDSTF(KPT+1)=R
CC C=Q(JK+2)
CC ENDSTF(KPT+2)=C
ENDSTF(KPT+2)=Q(JK+2)
ENDSTF(KPT+3)=1
CC ENDSTF(KPT+4)=Q(JK+4)
ENDSTF(KPT+4)=R4
ENDSTF(KPT+5)=Q(JK+5)
ENDSTF(KPT+7)=R7
ENDSTF(KPT+8)=R8
ENDSTF(KPT+6)=RR
236 KPT=KPT+13
ENDSTF(KPT)=0
Q(JK+6)=201
GO TO 30
C*************
35 IF(R.NE.2)GO TO 36
IF(RS.EQ.7)GO TO 30
C SKIP ALL THIS IF NEW CENTERING (P9 NOW HAS POS.)
IF(RS.LT.6.)GO TO 30
RR=RIGHT(NA,-1,JK)
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1,JK)-RR)/2.
C FUNCTION 'RIGHT' FINDS ITEMS TO LFT AND RT OF REST FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
CLEF=CLEFN(Q,JK)
LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
RCLEF(LL)=CLEF
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GT.100.)SIG=-99
C DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 130
38 Q(JK+1)=R/11.
GO TO 30
130 IF(Q(JK+3).LT.199)GO TO 30
IF(R.NE.18)GO TO 30
KKK=K+1
R3=9
IF(SIG.NE.-99)R3=14
KK=JK
435 LL=KPN(KKK)
C WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
ENDSTF(KPT)=Q(KK)
ENDSTF(KPT+1)=R
ENDSTF(KPT+2)=Q(KK+2)
ENDSTF(KPT+3)=R3
DO 535 JJ2=4,12
535 ENDSTF(KPT+JJ2)=Q(KK+JJ2)
KPT=KPT+13
ENDSTF(KPT)=0
RS=Q(LL+1)
IF(RS.LE.4)GO TO 30
R4=Q(LL+2)
C SAVE THE STAFF NUM. IN R4
IF(RS.NE.18)GO TO 7011
335 R3=R3+6
KK=LL
KKK=KKK+1
GO TO 435
7011 RS=CODEN(KPN,KKK+1,Q,LL)
IF(RS.LE.4)GO TO 30
IF(Q(LL+2).NE.R4)GO TO 30
IF(RS.EQ.18)GO TO 335
30 JPQ=KPN(NA+1)-KPN(NA)+JPQ
IF(NA.LT.I)GO TO 131
C END OF LOOP ****************
CALL PSHFT(I)
C NEXT GETS RID OF USELESS SLURS (NO LENGTH)
K=1
441 IF(CODEN(KWDS,K,RN,J).NE.5)GO TO 41
IF(ABS(RN(J+6)-RN(J+3)).GT..2)GO TO 41
C NEXT DELETES THE SLUR
LL=RN(J)+3
DO 241 NA=J,JPQ
241 RN(NA)=RN(NA+LL)
JPQ=JPQ-LL
CCC LL=KPN(K+2)-KPN(K+1)-LL
I=I-1
KP=KP-1
DO 341 NA=K+1,KP
341 KWDS(NA)=KWDS(NA+1)-LL
GO TO 441
41 K=K+1
IF(K.LT.KP-1)GO TO 441
RS=-1
C -1 FOR ALL STAVES AT ONCE IN GETPTS.
CCC RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-1
IF(IPG.GE.0)GO TO 46
C JUMP IF NOT IN 'PARTS' MODE (SINGLE STAFF)
RSTFAC(0)=SIZX
GO TO 246
46 DO 146 K=0,JPG-1
146 RSTFAC(K)=RSTFAC(K)*SIZE
C GETS PROPER SIZE FACTORS FOR JUSTIFY SUBR.
246 CALL PTMOVE(RN,KWDS)
C START LAST LOOP *******
CC DO 47 JJ2=1,KP
CC LL=KWDS(JJ2)
CC AA=RN(LL+1)
CC IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
CN IF(AA.NE.10.AND.AA.NE.16)GO TO 347
C***** SKIP NEXT FOR NOW ******* 1/28/78
CC GO TO 47
CC DO 147 NN=JJ2+1,KP
CC MM=KWDS(NN)
CC IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
CC IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
CC IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
CC IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
CC AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
CC IF(RN(MM+3).LT.AA)RN(MM+3)=AA
CC GO TO 47
CC247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
CC AA=RN(LL+4)+7
CC IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
CC GO TO 47
CC147 CONTINUE
CC GO TO 47
CC1047 IF(AA.NE.6)GO TO 47
CC IF(RN(LL).LT.7)GO TO 47
CC IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
CC47 CONTINUE
2 KWDS(KP)=JPQ
CP J=1
IF(KP.GE.300.OR.JPQ.GE.2500)TYPE 20,KP,JPQ
JJ2=KP+1
C WRITES 1 EXTRA WORD
CP JPQ=KB
DO 12 K=1,KP
CC N=KWDS(K)
CC R=RN(N+1)
R=CODEN(KWDS,K,RN,N)
IF(R.LE.2)GO TO 22
C ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
IF(R.GT.7)GO TO 12
IF(R.EQ.5)GO TO 52
IF(R.NE.4)GO TO 62
IF(RN(N).GE.4)GO TO 52
62 IF(R.NE.7)GO TO 12
52 A=RN(N+6)
C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
IF(A.GE.0)GO TO 12
J=A
IF(J.EQ.0)J=-1
B=RN(N+2)
C B=STAFF NUM.
JJ=0
DO 32 KK=K+1,KP
CC NN=KWDS(KK)
CC A=RN(NN+1)
R3=CODEN(KWDS,KK,RN,NN)
IF(R3.NE.1)GO TO 32
IF(B.NE.RN(NN+2))GO TO 32
D=RN(NN+3)
JJ=JJ-1
IF(J.NE.JJ)GO TO 32
CCC IF(J.NE.JJ)GO TO 42
3232 RN(N+6)=D
CC3232 RN(N+6)=D+(D-A)*(RN(N+6)-J)
C FOUND NOTE FOR POSITION.
IF(R.NE.5)GO TO 12
IF(J.EQ.-1)GO TO 12
IF(ABS(RN(N+7)).NE.1)GO TO 12
C NOW FIX UP CURVATURE OF SLUR. ('FAIL' ROUTINE)
D=RCURVE(RN(N+3))
RN(N+7)=D
GO TO 12
CC42 A=D
32 CONTINUE
12 CONTINUE
22 CALL PUTEXT(NAMX,EXT)
LCNT=0
CC NDPY=0
RSTFAC(99)=0
C MUST BE 0 IN MS TO MAKE DISPLAY
CALL EXTOUT(RSTFAC,128)
CALL EXTOUT(KWDS,JJ2)
CALL EXTOUT(RN,JPQ)
TYPE 101,NAMX,EXT
NAMX=NAMX+2
CC IF(IPG)GO TO 6011
NPG=NPG+1
IF(NBAR(LC).NE.0)GO TO 220
KK=LC+1
IF(NBAR(KK).EQ.0)GO TO 220
CHECK FOR ZEROS WHICH ARE PAGE MARKS.
LC=LC+1
221 KK=KK+1
IF(NBAR(KK).NE.0)GO TO 221
C FIND NEW MPG
MPG=KK-LC
NPG=1000
SPG=10./MPG
JEND=0
C RESET ABOVE
220 IF(NPG.LE.MPG)GO TO 6011
NPG=1
C RESET, UPDATE FILENAMES
NAMX=NAMZ+256
NAMZ=NAMX
6011 NAMQ=NAMX
CALL FINEXT
GO TO 100
C IPG=1 = GO BACK TO TRONLY INSTEAD
101 FORMAT(1XA5,'.',A3)
20 FORMAT(' TOO MUCH DATA!!! ',I3,'/300',I5,'/2500')
END